home *** CD-ROM | disk | FTP | other *** search
/ CD Exchange / CD Exchange - Volume 1.iso / utils / misc / siod / scm / esp-cont-pro.scm < prev    next >
Encoding:
Text File  |  1993-08-28  |  4.9 KB  |  185 lines
  1. (define (self-evaluating? exp) (number? exp))
  2.  
  3. (define (quoted? exp)
  4.         (if (atom? exp)
  5.             nil
  6.             (eq? (car exp) 'quote)))
  7.  
  8. (define (text-of-quotation exp) (cadr exp))
  9.  
  10. (define (variable? exp) (symbol? exp))
  11.  
  12. (define (assignment? exp)
  13.         (if (atom? exp)
  14.             nil
  15.             (eq? (car exp) 'set!)))
  16.  
  17. (define (assignment-variable exp) (cadr exp))
  18.  
  19. (define (assignment-value exp) (caddr exp))
  20.  
  21. (define (definition? exp)
  22.         (if (atom? exp)
  23.             nil
  24.             (eq? (car exp) 'define)))
  25.  
  26. (define (definition-variable exp)
  27.         (if (variable? (cadr exp))
  28.             (cadr exp)
  29.             (caadr exp)))
  30.  
  31. (define (definition-value exp)
  32.         (if (variable? (cadr exp))
  33.             (caddr exp)
  34.             (cons 'lambda
  35.                   (cons (cdadr exp)
  36.                         (cddr exp)))))
  37.  
  38. (define (lambda? exp)
  39.         (if (atom? exp)
  40.             nil
  41.             (eq? (car exp) 'lambda)))
  42.  
  43. (define (conditional? exp) 
  44.         (if (atom? exp)
  45.             nil
  46.             (eq? (car exp) 'cond)))
  47.  
  48. (define (clauses exp) (cdr exp))
  49.  
  50. (define (no-clauses? clauses) (null? clauses))
  51.  
  52. (define (first-clause clauses) (car clauses))
  53.  
  54. (define (rest-clauses clauses) (cdr clauses))
  55.  
  56. (define (true? x) (not (null? x)))
  57.  
  58. (define (else-clause? clause)
  59.         (eq? (predicate clause) 'else))
  60.  
  61. (define (last-exp? seq) (null? (cdr seq)))
  62.  
  63. (define (first-exp seq) (car seq))
  64.  
  65. (define (rest-exp seq) (cdr seq))
  66.  
  67. (define (application? exp) (not (atom? exp)))
  68.  
  69. (define (operator app) (car app))
  70.  
  71. (define (operands app) (cdr app))
  72.  
  73. (define (no-operands? args) (null? args))
  74.  
  75. (define (first-operand args) (car args))
  76.  
  77. (define (rest-operands args) (cdr args))
  78.  
  79. (define (make-procedure lambda-exp env)
  80.         (list 'procedure lambda-exp env))
  81.  
  82. (define (compound-procedure? proc)
  83.         (if (atom? proc)
  84.             nil
  85.             (eq? (car proc) 'procedure)))
  86.  
  87. (define (parameters proc) (cadr (cadr proc)))
  88.  
  89. (define (procedure-body proc) (cddr (cadr proc)))
  90.  
  91. (define (procedure-envirot proc) (caddr proc))
  92.  
  93. (define (lookup-variable-value var env)
  94.         (let ((b (binding-in-env var env)))
  95.              (if (found-binding? b)
  96.                  (binding-value b)
  97.                  (error "unbound variable" var))))
  98.  
  99. (define (binding-in-env var env)
  100.         (if (no-mor-frames? env)
  101.             no-binding
  102.             (let ((b (binding-in-frame var (first-frame env))))
  103.                  (if (found-binding? b)
  104.                      b
  105.                      (binding-in-env var (rest-frames env))))))
  106.  
  107. (define (extend-environment variables value base-env)
  108.         (adjoin-frame (make-frame variables values) base-env))
  109.  
  110. (define (set-variable-value! var val env)
  111.         (let ((b (binding-in-frame var (first frame env))))
  112.              (if (found-binding? b)
  113.                  (set-binding-value! b val)
  114.                  (set-first-frame! env (adjoin-binding (make-binding var val)
  115.                                                        (first-frame env))))))
  116.  
  117. (define (first-frame env) (car env))
  118.  
  119. (define (rest-frames env) (cdr env))
  120.  
  121. (define (no-more-frames? env) (null? env))
  122.  
  123. (define (adjoin-frame frame env) (cons frame env))
  124.  
  125. (define (set-first-frame! env new-frame)
  126.         (set-car! env new-frame))
  127.  
  128. (define (make-frame variables values)
  129.         (cond ((and (null? variables) (null? values)) '())
  130.               ((null? variables)
  131.                (error "too many values supplied" values))
  132.               ((null? values)
  133.                (error "too few values supplied" variables))
  134.               (else (cons (make-binding (car variables) (car values))
  135.                           (make-frame (cdr variables) (cdr values))))))
  136.  
  137. (define (adjoin-binding binding frame)
  138.         (cons binding frame))
  139.  
  140. (define (assq key bindings)
  141.         (cond ((null? bindings) no-binding)
  142.               ((eq? key (binding-variable (car bindings))) 
  143.                   (car bindings)) 
  144.               (else (assq key (cdr bindings)))))
  145.  
  146. (define (binding-in-frame var frame)
  147.         (assq var frame))
  148.  
  149. (define (found-binding? b)
  150.         (not (eq? b no-binding)))
  151.  
  152. (define no-binding nil)
  153.  
  154. (define (make-binding variable value)
  155.         (cons variable value))
  156.  
  157. (define (binding-variable binding)
  158.         (car binding))
  159.  
  160. (define (binding-value binding)
  161.         (cdr binding))
  162.  
  163. (define (set-binding-value! binding value)
  164.         (set-cdr! binding value))
  165.  
  166. (define (user-print object)
  167.         (cond ((compound-procedure? object)
  168.               (print (list 'compound-procedure
  169.                            (parameters object)
  170.                            (procedure-body object)
  171.                            '[procedure-env])))
  172.               (else (print object))))
  173.  
  174. (define (make-bindings proc args)
  175.         (extend-binding-environment (parameters proc)
  176.                                     args
  177.                                     (procedure-environment proc)))
  178.  
  179. (define (extend-binding-environment vars args env)
  180.         (extend-environment vars (reverse args) env)) 
  181.  
  182. (define the-global-environment (setup-environment))
  183.  
  184. (start explicit-control-evaluator)
  185.